Windows Game Programming for Dummies (2nd Edition)/WinGamProgFD.iso/mac/DirectX SDK/DXSDK/samples/Multimedia/VBSamples/Direct3D/Donuts/donuts.frm

Text File | 2001-10-08 | 38KB | 1,134 lines

VERSION 5.00
Begin VB.Form frmVBDonuts
   Caption         =   "VBDonuts"
   ClientHeight    =   4440
   ClientLeft      =   60
   ClientTop       =   345
   ClientWidth     =   5355
   Icon            =   "Donuts.frx":0000
   LinkTopic       =   "Form1"
   ScaleHeight     =   296
   ScaleMode       =   3  'Pixel
   ScaleWidth      =   357
   StartUpPosition =   3  'Windows Default
End
Attribute VB_Name = "frmVBDonuts"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit

'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'
'  Copyright (C) 1999-2001 Microsoft Corporation.  All Rights Reserved.
'
'  File:       Donuts.frm
'  Content:    This sample shows how 2d can be simulated with Direct3D using
'              transformed and lit vertices.
'
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

'Set the constant for full screen operation.
Const FULLSCREENWIDTH = 640
Const FULLSCREENHEIGHT = 480

'Set the number of sprites used in the sample.
Const NUM_SPRITES = 100

'Set the maximum velocity of the sprites.
Const MAX_VELOCITY = 1.5

'Flexible vertex format the describes transformed and lit vertices.
Const FVF = D3DFVF_XYZRHW Or D3DFVF_TEX1 Or D3DFVF_DIFFUSE Or D3DFVF_SPECULAR

'This structure describes a transformed and lit vertex.
Private Type TLVERTEX
    x As Single
    y As Single
    z As Single
    rhw As Single
    color As Long
    specular As Long
    tu As Single
    tv As Single
End Type

'A structure that defines all the needed properties
'of the Sprite.
Private Type typeSprite
    AnimDimensions As Single        'The dimensions of one frame of animation.
    AnimSpeed As Single             'The speed at which the animation occurs.
    AnimTheta As Single             'The current animation time count.
    FramesPerRow As Long            'How many animation frames are contained in one row in the texture.
    FramesTotal As Long             'Total number of frames for this animation.
    FrameCurrent As Single          'The current animation frame.
    RowOffset As Single             'Offset of the texture start for this sprite.
    SpriteDimensions As Single      'The dimensions of this sprite as will be displayed on the screen in pixels.
    SpriteNum As Long               'The index of this sprite.
    SpriteVerts(3) As TLVERTEX   'Vertex information for this sprite.
    Velocity As D3DVECTOR2          'The velocity of this sprite.
    Location As D3DVECTOR2          'The location of this sprite.
End Type

Dim m_Sprite(NUM_SPRITES) As typeSprite

'Dim the DirectX objects/structs the app uses.
Dim dx As DirectX8
Dim d3d As Direct3D8
Dim dev As Direct3DDevice8
Dim d3dx As D3DX8
Dim d3dtBackground As Direct3DTexture8
Dim d3dtSprite As Direct3DTexture8
Dim m_d3dpp As D3DPRESENT_PARAMETERS

'Dim the vertices for the background DirectX logo.
Dim m_MainVerts(3) As TLVERTEX

'Module level boolean that determines whether
'the app is in fullscreen or windowed.
Dim m_bWindowed As Boolean

'Module level variable to store the caps of the device.
Dim m_D3DCaps As D3DCAPS8

'Module level variable to store the display mode.
Dim m_d3ddm As D3DDISPLAYMODE

'Module level variables to store the window dimensions.
Dim m_lWindowWidth As Long
Dim m_lWindowHeight As Long

'Variables to store the render surface width and height.
Dim m_lClientWidth As Long
Dim m_lClientHeight As Long

'Module level variable to store app state.
Dim m_bRunning As Boolean

Private Sub Form_Load()

    'Show and size the form.
    With Me
        .Show
        .Height = .ScaleY(300, vbPixels, vbTwips)
        .Width = .ScaleX(400, vbPixels, vbTwips)
    End With

    'Seed the random number generator.
    Call Randomize

    'Call the sub to initialize the app.
    Call InitApp

    'Start the main loop of the sample.
    Call MainLoop

End Sub

Private Sub InitApp()

    '***********************************************************************
    '
    ' This sub initializes the application.
    '
    ' Parameters:
    '
    '           None.
    '
    '***********************************************************************

    Dim lErrNum As Long

    'Store the current window dimensions
    m_lWindowWidth = Me.ScaleWidth
    m_lWindowHeight = Me.ScaleHeight

    'Call the function that initializes the DirectX8, Direct3D8, and Direct3DDevice8 objects.
    lErrNum = InitD3D(dx, d3d, dev, Me.hwnd)
    If lErrNum Then
        'There was an error. We'll need to exit out at this point.
        Unload Me
    End If

    'Set the d3dx variable to a new D3DX8 object
    Set d3dx = New D3DX8

    'Call the function to load any textures.
    Call InitTextures

End Sub

Private Sub MainLoop()

    '***********************************************************************
    '
    ' This sub is the main loop for the sample.
    '
    ' Parameters:
    '
    '           None.
    '
    '***********************************************************************

    m_bRunning = True

    Do While m_bRunning

        Call RenderScene
        DoEvents

    Loop

    'Exiting app now
    Unload Me

End Sub

Private Sub RenderScene()

    '***********************************************************************
    '
    ' This sub handles the rendering of the scene.
    '
    ' Parameters:
    '
    '   None.
    '
    '***********************************************************************

    On Local Error Resume Next

    Dim hr As Long

    'Call TestCooperativeLevel to see what state the device is in.
    hr = dev.TestCooperativeLevel

    If hr = D3DERR_DEVICELOST Then

        'If the device is lost, exit and wait for it to come back.
        Exit Sub

    ElseIf hr = D3DERR_DEVICENOTRESET Then

        'The device became lost for some reason (probably an alt-tab) and now
        'Reset() needs to be called to try and get the device back.
        hr = 0
        hr = ResetDevice()

        'If the device failed to be reset, exit the sub.
        If hr Then Exit Sub

    End If

    'Make sure the app isn't minimized.
    If Me.WindowState <> vbMinimized Then

        'The app is ready for rendering.
        With dev

            'Clear the back buffer
            Call .Clear(0, ByVal 0&, D3DCLEAR_TARGET, &HFF, 0, 0)

            'Begin the 3d scene
            Call .BeginScene

            'Set the background texture on the device
            Call .SetTexture(0, d3dtBackground)

            'Draw the 2 polygons that make up the background
            Call .DrawPrimitiveUP(D3DPT_TRIANGLESTRIP, 2, m_MainVerts(0), Len(m_MainVerts(0)))

            'Call the sub that renders the sprites
            Call RenderSprites

            'End the scene
            Call .EndScene

            'Draw the graphics to the front buffer.
            Call .Present(ByVal 0&, ByVal 0&, 0, ByVal 0&)

        End With

    End If

End Sub

Private Sub RenderSprites()

    '***********************************************************************
    '
    ' This sub handles the rendering and animation of the sprites.
    '
    ' Parameters:
    '
    '   None.
    '
    '***********************************************************************

    Dim i As Long
    Dim TexX As Single, TexY As Single

    With dev

        'Set the Sprite texture on the device
        Call .SetTexture(0, d3dtSprite)

        'Make sure the device supports alpha blending
        If (m_D3DCaps.TextureCaps And D3DPTEXTURECAPS_ALPHA) Then

            'It does, so turn alpha blending on
            Call .SetRenderState(D3DRS_ALPHABLENDENABLE, 1)

        End If

       For i = 0 To UBound(m_Sprite)

            'Call the sub that updates the Sprite
            Call UpdateSprite(i)

            'Draw the 2 polygons that make up the Sprite
            Call .DrawPrimitiveUP(D3DPT_TRIANGLESTRIP, 2, m_Sprite(i).SpriteVerts(0), Len(m_Sprite(i).SpriteVerts(0)))

        Next


        'If alpha blending was turned on
         If .GetRenderState(D3DRS_ALPHABLENDENABLE) Then

            'Turn it back off
            Call .SetRenderState(D3DRS_ALPHABLENDENABLE, 0)

        End If

    End With

End Sub

Private Sub UpdateSprite(ByVal index As Long)

    '***********************************************************************
    '
    ' This sub updates the sprites texture coordinates and position.
    ' Direc3DDevice8.
    '
    ' Parameters:
    '
    ' [IN]
    '       index:      The index of the Sprite to update.
    '
    '***********************************************************************

    Dim TexX As Single, TexY As Single

    With m_Sprite(index)

        'Update the theta for this sprite.
        .AnimTheta = .AnimTheta + .AnimSpeed

        'If the theta count is greater than one, advance the animation frame.
        If .AnimTheta > 1 Then

            'Reset theta
            .AnimTheta = 0

            'Advance the animation frame
            .FrameCurrent = .FrameCurrent + 1
            If .FrameCurrent >= .FramesTotal Then
                .FrameCurrent = 0
            End If

        End If

        'Calculate the updated texture coordinates for this Sprite
        TexY = ((.FrameCurrent \ .FramesPerRow) * .AnimDimensions) + .RowOffset
        TexX = (.FrameCurrent Mod .FramesPerRow) * .AnimDimensions

        'Update the position of the Sprite
        .Location.x = .Location.x + .Velocity.x
        .Location.y = .Location.y + .Velocity.y

        .SpriteVerts(0).x = .Location.x
        .SpriteVerts(0).y = .Location.y + .SpriteDimensions
        .SpriteVerts(0).tu = TexX
        .SpriteVerts(0).tv = TexY + .AnimDimensions

        .SpriteVerts(1).x = .Location.x
        .SpriteVerts(1).y = .Location.y
        .SpriteVerts(1).tu = TexX
        .SpriteVerts(1).tv = TexY

        .SpriteVerts(2).x = .Location.x + .SpriteDimensions
        .SpriteVerts(2).y = .Location.y + .SpriteDimensions
        .SpriteVerts(2).tu = TexX + .AnimDimensions
        .SpriteVerts(2).tv = TexY + .AnimDimensions

        .SpriteVerts(3).x = .Location.x + .SpriteDimensions
        .SpriteVerts(3).y = .Location.y
        .SpriteVerts(3).tu = TexX + .AnimDimensions
        .SpriteVerts(3).tv = TexY

        'Check to see if the Sprite hit a wall. If it did, reverse its velocity.
        If .Location.x <= 0 Then
            .Velocity.x = -1 * .Velocity.x
        ElseIf .Location.x + .SpriteDimensions >= m_lClientWidth Then
            .Velocity.x = -1 * .Velocity.x
        End If

        If .Location.y <= 0 Then
            .Velocity.y = -1 * .Velocity.y
        ElseIf .Location.y + .SpriteDimensions >= m_lClientHeight Then
            .Velocity.y = -1 * .Velocity.y
        End If

    End With

End Sub

Private Function InitD3D(dx As DirectX8, d3d As Direct3D8, dev As Direct3DDevice8, ByVal hwnd As Long, Optional ByVal bWindowed As Boolean = True) As Long

    '***********************************************************************
    '
    ' This function creates the following objects: DirectX8, Direct3D8,
    ' Direc3DDevice8.
    '
    ' Parameters:
    '
    ' [IN]
    '       hwnd:       Handle to a window that will be used as the render target
    '       bWindowed:  Optional boolean argument that initializes either full screen
    '                   or windowed. Default is windowed.
    ' [OUT]
    '       dx:         Pass in an uninitialized DirectX8 object.
    '       d3d:        Pass in an uninitialized Direct3D8 object.
    '       dev:        Pass in an uninitialized Direct3DDevice8 object.
    '
    ' Return value:
    '
    '     If an error occurs, it returns the Direct3D error number. In the
    '     case that no fullscreen format was found, it returns D3DERR_INVALIDDEVICE.
    '
    '***********************************************************************

    Dim DevType As CONST_D3DDEVTYPE
    Dim i As Long, lCount As Long, lErrNum As Long, format As Long
    Dim bFoundMode As Boolean

    'Turn off error checking. The app will check for errors and handle them.
    On Local Error Resume Next

    'Store the window mode that was passed in
    m_bWindowed = bWindowed

    'Initiazlize the DirectX8 object
    Set dx = New DirectX8

    'Check to make sure that the dx object was created successfully.
    If Err.Number Then

        'There were problems creating the dx object. Return the error number.
        InitD3D = Err.Number
        Exit Function

    End If

    'Create the Direct3D object
    Set d3d = dx.Direct3DCreate

    'Check to make sure that the d3d object was created successfully.
    If Err.Number Then

        'There were problems creating the d3d object. Return the error number,
        InitD3D = Err.Number
        Exit Function

    End If

    'We'll start by attempting to create a HAL device. This variable
    'will hold the final type of device that we create after we check
    'some capabilities.
    DevType = D3DDEVTYPE_HAL

    'Get the capabilities of the Direct3D device that we specify. In this case,
    'we'll be using the adapter default (the primiary card on the system).
    Call d3d.GetDeviceCaps(D3DADAPTER_DEFAULT, DevType, m_D3DCaps)

    'Check for errors. If there is an error, the card more than likely doesn't support at least DX7,
    'so get the caps of the reference device instead.
    If Err.Number Then

        Err.Clear
        DevType = D3DDEVTYPE_REF
        Call d3d.GetDeviceCaps(D3DADAPTER_DEFAULT, DevType, m_D3DCaps)

        'If there is *still* an error, then the driver has problems. We'll
        'have to exit at this point, because there isn't anything else we can
        'do.
        If Err.Number Then
            InitD3D = D3DERR_NOTAVAILABLE
            Exit Function
        End If

    End If

    'Grab some information about the current display mode.
    Call d3d.GetAdapterDisplayMode(D3DADAPTER_DEFAULT, m_d3ddm)

    'Now we'll go ahead and fill the D3DPRESENT_PARAMETERS type.
    With m_d3dpp

        If bWindowed Then

            'Make sure that the adapter is in a color bit-depth greater than 8 bits per pixel.
            If m_d3ddm.format = D3DFMT_P8 Or m_d3ddm.format = D3DFMT_A8P8 Then
                'Device is running in some variation of an 8 bit format
                MsgBox " For this sample to run, the primary display needs to be in 16 bit or higher color depth.", vbCritical
                InitD3D = D3DERR_INVALIDDEVICE
                Exit Function
            Else
                'Device is greater than 8 bit. Set the format variable to the current display format.
                format = m_d3ddm.format
            End If

            'For windowed mode, we just discard any information instead of flipping it.
            .SwapEffect = D3DSWAPEFFECT_DISCARD

            'Set windowed mode to true.
            .Windowed = 1

        Else

            'Call the sub to find the first suitable fullscreen format
            lErrNum = FindMode(FULLSCREENWIDTH, FULLSCREENHEIGHT, format)

            'If unable to find a suitable mode, the app will have to exit.
            If lErrNum Then
                MsgBox " Unable to find a compatible format to run the sample.", vbCritical
                InitD3D = D3DERR_INVALIDDEVICE
                Exit Function
            End If

            'We need the backbuffer to flip with the front for fullscreen. This
            'flag enables this.
            .SwapEffect = D3DSWAPEFFECT_FLIP

            'Set the width and height
            .BackBufferWidth = FULLSCREENWIDTH
            .BackBufferHeight = FULLSCREENHEIGHT

        End If

        'Set the backbuffer format
        .BackBufferFormat = format

    End With

    'Try to create the device now that we have everything set.
    Set dev = d3d.CreateDevice(D3DADAPTER_DEFAULT, DevType, hwnd, D3DCREATE_SOFTWARE_VERTEXPROCESSING, m_d3dpp)

    'If the creation above failed, try to create a REF device instead.
    If Err.Number Then

        Err.Clear
        Set dev = d3d.CreateDevice(D3DADAPTER_DEFAULT, D3DDEVTYPE_REF, hwnd, D3DCREATE_SOFTWARE_VERTEXPROCESSING, m_d3dpp)

        If Err.Number Then

            'The app still hit an error. Both HAL and REF devices weren't created. The app will have to exit at this point.
            InitD3D = Err.Number
            Exit Function

        End If
    End If

    'Store the client dimensions
    If m_bWindowed Then
        m_lClientWidth = Me.ScaleWidth
        m_lClientHeight = Me.ScaleHeight
    Else
        m_lClientWidth = FULLSCREENWIDTH
        m_lClientHeight = FULLSCREENHEIGHT
    End If

    If InitDevice(dev, hwnd) Then

        MsgBox "Unable to initialize the device"
        Unload Me

    End If

End Function

Private Function InitDevice(dev As Direct3DDevice8, hwnd As Long) As Long

    '***********************************************************************
    '
    ' This function initializes the device with some renderstates, and also
    ' sets up the viewport, camera, and world.
    '
    ' Parameters:
    '
    ' [IN]
    '       dev:    An existing Direct3DDevice8 object
    '       m_d3dpp:  A filled D3DPRESENT_PARAMETERS type
    '       hwnd:   Handle to the target window
    '
    '
    ' Return value:
    '     If an error occurs, it returns D3DERR_INVALIDCALL.
    '
    '***********************************************************************

    'On Local Error Resume Next
    Call InitGeometry

    With dev

        'Set the vertex shader to an FVF that contains texture coords,
        'and transformed and lit vertex coords.
        Call .SetVertexShader(FVF)

        'Turn off lighting
        Call .SetRenderState(D3DRS_LIGHTING, 0)

        'Set the render state that uses the alpha component as the source for blending.
        Call .SetRenderState(D3DRS_SRCBLEND, D3DBLEND_SRCALPHA)

        'Set the render state that uses the inverse alpha component as the destination blend.
        Call .SetRenderState(D3DRS_DESTBLEND, D3DBLEND_INVSRCALPHA)

    End With

    If Err.Number Then InitDevice = D3DERR_INVALIDCALL

End Function

Private Sub InitGeometry()

    '***********************************************************************
    '
    ' This sub initializes the vertices for all the needed polygons.
    '
    ' Parameters:
    '           None.
    '
    '***********************************************************************

    Dim sDimensions As Single
    Dim i As Long
    Static bInit As Boolean

    ' All the polygons that this sample use are made of two triangles that create a rectangle.
    ' The textures are painted on these two polygons to create the look of a 2d sprite.
    ' All of the polygons are transformed and lit, meaning that Direct3D will perform no
    ' lighting calculations, and no coordinate transformation. The application is responsible
    ' for doing all of these calculations. Since this is just a 2d simulation, it's very easy
    ' to set up the polygons and transform them manually.
    ' This illustration shows the placement of each vertex (vn) to draw the rectangle. Notice the
    ' order that the vertices are placed. This follows the clockwise winding order rule for culling
    ' polygons. If the order was reversed, the polygon wouldn't be rendered by Direct3D. See the "3-D
    ' Coordinate Systems and Geometry" section in the docs for more info.

    ' * v1      * v3
    ' |\        |
    ' |  \      |
    ' |    \    |
    ' |      \  |
    ' |        \|
    ' * v0      * v2

    'Initialize the 2 polygons that will display the DirectX logo
    With m_MainVerts(0)

        'X and Y are the familiar XY values in screen space that this vertex will be placed.
        'This one is going in the bottom left corner of the screen.
        .x = 0: .y = m_lClientHeight

        'This sets up the texture coordinates for this vertex in the polygon.
        'tu is the X of the texture, tv is the Y of the texture. Texture coordinates
        'are from 0 to 1, 0 being all the way to the left or top, and 1 being all the
        'way to the right or bottom, depending on whether it is the tu or tv element.
        .tu = 0: .tv = 1

        'rhw is the value that D3D uses to produce scaling. Since this app
        'won't be doing any scaling, this value needs to be 1.
        .rhw = 1

        'Since the app will handle all lighting, the color value will be used
        'to light the polygon. For this app, the polygon will be fully lit.
        .color = &HFFFFFF
    End With

    'The rest of the vertices follow the same format, but are placed in different XY coordinates.

    With m_MainVerts(1)
        .x = 0: .y = 0
        .tu = 0: .tv = 0
        .rhw = 1
        .color = &HFFFFFF
    End With
    With m_MainVerts(2)
        .x = m_lClientWidth: .y = m_lClientHeight
        .tu = 1: .tv = 1
        .rhw = 1
        .color = &HFFFFFF
    End With
    With m_MainVerts(3)
        .x = m_lClientWidth: .y = 0
        .tu = 1: .tv = 0
        .rhw = 1
        .color = &HFFFFFF
    End With

    For i = 0 To UBound(m_Sprite)

        With m_Sprite(i)

            'If this is the first time the sub is called.
            If Not bInit Then

                'Choose a random Sprite
                .SpriteNum = Int((3) * Rnd)

                'Set the sprites properties accordingly
                If .SpriteNum = 0 Then
                    .FramesPerRow = 8
                    .FramesTotal = 29
                    .RowOffset = 0
                    .AnimDimensions = 0.125
                    .SpriteDimensions = 40
                ElseIf .SpriteNum = 1 Then
                    .FramesPerRow = 16
                    .FramesTotal = 39
                    .RowOffset = 0.5
                    .AnimDimensions = 0.0625
                    .SpriteDimensions = 15
                ElseIf .SpriteNum = 2 Then
                    .FramesPerRow = 16
                    .FramesTotal = 39
                    .RowOffset = 0.6875
                    .AnimDimensions = 0.0625
                    .SpriteDimensions = 15
                End If

                'Choose a random starting location, velocity, and animation frame
                .Location.x = (m_lClientWidth - .SpriteDimensions) * Rnd
                .Location.y = (m_lClientHeight - .SpriteDimensions) * Rnd
                .Velocity.x = (((MAX_VELOCITY - -MAX_VELOCITY) * Rnd) + -MAX_VELOCITY)
                .Velocity.y = (((MAX_VELOCITY - -MAX_VELOCITY) * Rnd) + -MAX_VELOCITY)
                .FrameCurrent = Int(.FramesTotal * Rnd)

                'Calculate the speed at which the animation should occurr. Based on the velocity of the sprite.
                'The higher the velocity, the faster the animation.
                .AnimSpeed = ((Abs(.Velocity.x) + Abs(.Velocity.y)) / 4)

            Else

                'The window was resized. Make sure sprites are still in view, move them so they are if neccessary.
                If .Location.x + .SpriteDimensions > m_lClientWidth Then
                    .Location.x = m_lClientWidth - .SpriteDimensions - 1
                End If

                If .Location.y + .SpriteDimensions > m_lClientHeight Then
                    .Location.y = m_lClientHeight - .SpriteDimensions - 1
                End If

            End If

            'Create the vertices for the Sprite
            With .SpriteVerts(0)
                .x = 0: .y = 0
                .tu = 0: .tv = m_Sprite(i).AnimDimensions
                .rhw = 1
                .color = &HFFFFFF
            End With
            With .SpriteVerts(1)
                .x = 0: .y = m_Sprite(i).SpriteDimensions
                .tu = 0: .tv = 0
                .rhw = 1
                .color = &HFFFFFF
            End With
            With .SpriteVerts(2)
                .x = m_Sprite(i).SpriteDimensions: .y = 0
                .tu = m_Sprite(i).AnimDimensions: .tv = m_Sprite(i).AnimDimensions
                .rhw = 1
                .color = &HFFFFFF
            End With
            With .SpriteVerts(3)
                .x = m_Sprite(i).SpriteDimensions: .y = m_Sprite(i).SpriteDimensions
                .tu = m_Sprite(i).AnimDimensions: .tv = 0
                .rhw = 1
                .color = &HFFFFFF
            End With

        End With

    Next

    'The geometry is initialized. No need to randomize again.
    bInit = True

End Sub

Private Sub InitTextures()

    '***********************************************************************
    '
    ' This sub loads any textures needed. If for some reason this sub doesn't
    ' succeed, we'll just exit the app, because it won't run without the
    ' textures being loaded.
    '
    ' Parameters:
    '           None.
    '
    '***********************************************************************

    On Local Error Resume Next

    Dim sFile As String

    'Locate the path to the media
    sFile = FindMediaDir("dx5_logo.bmp")
    If sFile = "" Then
        sFile = App.Path & "\" & "dx5_logo.bmp"
    Else
        sFile = sFile & "dx5_logo.bmp"
    End If

    'Check to make sure the media was found
    If Dir(sFile) = vbNullString Then
        MsgBox "Unable to locate sample media."
        Unload Me
    End If

    'Load the background texture
    Set d3dtBackground = d3dx.CreateTextureFromFile(dev, sFile)

    'Locate the path to the next media file.
    sFile = FindMediaDir("donuts1.bmp")
    If sFile = "" Then
        sFile = App.Path & "\" & "donuts1.bmp"
    Else
        sFile = sFile & "donuts1.bmp"
    End If

    'Check to make sure the media was found
    If Dir(sFile) = vbNullString Then
        MsgBox "Unable to locate sample media."
        Unload Me
    End If


    'Load the Sprite texture. We need to get alpha information embedded into this
    'surface, so we'll call the more complex CreateTextureFromFileEx() method instead.
    'The main thing we need to do is just let it know we want to use black as the
    'alpha channel. We do this by passing &HFF000000 to the method, and it fills in
    'the high order byte of any pixel that contains black with full alpha so that it
    'becomes transparent when rendered with alpha blending enabled.

    Set d3dtSprite = d3dx.CreateTextureFromFileEx( _
                                                    dev, _
                                                    sFile, _
                                                    D3DX_DEFAULT, _
                                                    D3DX_DEFAULT, _
                                                    D3DX_DEFAULT, _
                                                    0, _
                                                    D3DFMT_UNKNOWN, _
                                                    D3DPOOL_MANAGED, _
                                                    D3DX_FILTER_POINT, _
                                                    D3DX_FILTER_POINT, _
                                                    &HFF000000, _
                                                    ByVal 0, _
                                                    ByVal 0 _
                                                    )

    If Err.Number Then

        'Something happened while loading the texture.
        MsgBox "Error loading texture. Error number: " & Err.Number
        Unload Me

    End If

End Sub

Private Sub SwitchWindowMode()

    '***********************************************************************
    '
    ' This sub switches the current display mode between windowed/fullscreen.
    ' If it runs into an error, it just exits, leaving the display mode in
    ' its current state.
    '
    ' Parameters:
    '           None.
    '
    '***********************************************************************

    Dim d3dppEmpty As D3DPRESENT_PARAMETERS
    Dim format As Long
    Dim lErrNum As Long

    On Local Error Resume Next

    If m_bWindowed Then

        'Grab a valid format for this device. If a format
        'for the requested resolution wasn't found, exit the sub.
        If FindMode(FULLSCREENWIDTH, FULLSCREENHEIGHT, format) <> 0 Then Exit Sub

        'Store the current window mode format
        Call d3d.GetAdapterDisplayMode(D3DADAPTER_DEFAULT, m_d3ddm)

        'The app is running windowed currently, switch to fullscreen.
        m_bWindowed = False

        'Set the present parameters for running full screen
        m_d3dpp = d3dppEmpty

        With m_d3dpp
            .SwapEffect = D3DSWAPEFFECT_FLIP
            .BackBufferFormat = format
            .BackBufferWidth = FULLSCREENWIDTH
            .BackBufferHeight = FULLSCREENHEIGHT
            .Windowed = 0
        End With

        'Store the client dimensions
        m_lClientWidth = FULLSCREENWIDTH
        m_lClientHeight = FULLSCREENHEIGHT

        'Reset the device to the new mode
        lErrNum = ResetDevice

        'If there is an error resetting the device,
        'just exit the sub.
        If lErrNum Then
            'Store the client dimensions
            m_lClientWidth = Me.ScaleWidth
            m_lClientHeight = Me.ScaleHeight
            m_bWindowed = True
            Exit Sub
        End If

    Else

        'Set the present params to reflect windowed operation.
        m_d3dpp = d3dppEmpty

        With m_d3dpp
            .SwapEffect = D3DSWAPEFFECT_DISCARD
            .BackBufferFormat = m_d3ddm.format
            .Windowed = 1
        End With

        'Reset the device to the new mode
        lErrNum = ResetDevice

        'If there is an error, just exit the sub
        If lErrNum Then
            m_bWindowed = False
            Exit Sub
        End If

        'Now get the device ready again
        Call InitDevice(dev, Me.hwnd)

        'Resize the form to the size it was previous to going fullscreen.
        Me.Width = m_lWindowWidth * Screen.TwipsPerPixelX
        Me.Height = m_lWindowHeight * Screen.TwipsPerPixelY

        'The app is now running windowed
        m_bWindowed = True

        'Store the client dimensions
        m_lClientWidth = Me.ScaleWidth
        m_lClientHeight = Me.ScaleHeight

        'Resize the window to the old size now.
        Call Form_Resize

    End If

End Sub

Private Sub ResizeWindow()

    '***********************************************************************
    '
    ' This subroutine is called whenever the form is resized. It resets the
    ' device to the new size, and re-inits the device.
    '
    ' Parameters:
    '
    '   None.
    '
    '***********************************************************************

    Dim d3dppEmpty As D3DPRESENT_PARAMETERS

    m_lWindowWidth = Me.ScaleWidth
    m_lWindowHeight = Me.ScaleHeight
    m_lClientWidth = m_lWindowWidth
    m_lClientHeight = m_lWindowHeight

    'Reset the device to the new mode
    Call ResetDevice

End Sub

Private Function ResetDevice() As Long

    '***********************************************************************
    '
    ' This subroutine is called whenever the app needs to be resized, or the
    ' device has been lost.
    '
    ' Parameters:
    '
    '   None.
    '
    '***********************************************************************

    On Local Error Resume Next

    Call dev.Reset(m_d3dpp)

    If Err.Number Then
        ResetDevice = Err.Number
        Exit Function
    End If

    'Now get the device ready again
    Call InitDevice(dev, Me.hwnd)

End Function
Private Function FindMode(ByVal w As Long, ByVal h As Long, fmt As Long) As Long

    '***********************************************************************
    '
    ' This function returns a valid back buffer format for the width and height passed in.
    '
    ' Parameters:
    '
    ' [IN]
    '      w is the width of the mode being sought
    '      h is the height of the mode being sought
    '
    ' [OUT]
    '     fmt will be filled in with a valid CONST_D3DFORMAT
    '
    ' Return value:
    '     If a valid format was not found, D3DERR_INVALIDDEVICE is returned.
    '     If an error occurs, it returns D3DERR_INVALIDCALL.
    '***********************************************************************


    Dim i  As Long, lCount As Long
    Dim d3ddm As D3DDISPLAYMODE
    Dim bFoundMode As Boolean

    i = 0

    'Get the number of adapter modes this adapter supports.
    lCount = d3d.GetAdapterModeCount(D3DADAPTER_DEFAULT) - 1

    'If we encounter an error, return an error code and exit the function.
    If Err.Number Then
        FindMode = D3DERR_INVALIDCALL
        Exit Function
    End If

    'Next, loop through all the display modes until we find one
    'that matches the parameters passed in.
    For i = 0 To lCount

        Call d3d.EnumAdapterModes(D3DADAPTER_DEFAULT, i, d3ddm)

        'Again, catch any unexpected errors.
        If Err.Number Then
            FindMode = Err.Number
            Exit Function
        End If

        'Check to see if this mode matches what is being sought.
        If d3ddm.Width = w And d3ddm.Height = h Then

            'Now see if this mode is either a 32bpp or 16bpp mode
            If d3ddm.format = D3DFMT_R8G8B8 Or _
                d3ddm.format = D3DFMT_R5G6B5 Then

                'We've found a suitable display. Set the flag
                'to reflect this, and exit. No need to look further.
                bFoundMode = True

                'Set the fmt to the format that was found.
                fmt = d3ddm.format

                Exit For
            End If
        End If
    Next

    If bFoundMode Then

        'Everything checked out OK
        Exit Function

    Else

        'Return an error
        FindMode = D3DERR_INVALIDDEVICE

    End If

End Function

Private Sub Form_KeyDown(KeyCode As Integer, Shift As Integer)

    If (Shift And vbAltMask) And KeyCode = vbKeyReturn Then

        'User wants to switch from fullscreen/windowed mode
        Call SwitchWindowMode

    ElseIf KeyCode = vbKeyEscape Then

        'User wants to exit the app
        m_bRunning = False

    End If

End Sub

Private Sub Form_Resize()

    'Call the subroutine that resizes the backbuffer on the device.
    'Make sure the device exists, and the app is windowed.
    If Not dev Is Nothing And m_bWindowed Then

    'Make sure the app isn't minimized.
    If Me.WindowState <> vbMinimized Then

        'Make sure the app isn't resized to the point where the sprites could get stuck.
        If Me.ScaleHeight < 100 Or Me.ScaleWidth < 100 Then
            Me.Width = Screen.TwipsPerPixelX * 100
            Me.Height = Screen.TwipsPerPixelY * 100
        End If

            Call ResizeWindow
        End If

    End If

End Sub

Private Sub Form_Unload(Cancel As Integer)

    'We need to terminate the app using the End statement,
    'otherwise the form will reload since the app is running
    'in a loop with DoEvents.
    End

End Sub